C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  MAIN PROGRAM FOR TOOLPACK/IST TEXT FORMATTER: ISTRF
C  WAYNE R. COWELL - ANL
C  ROBERT M. J. ILES - NAG
C
      PROGRAM ISTRF
 
      INTEGER STATUS,FD,FDOPT,I
      INTEGER SRCFIL(81),OUTFIL(81),MSG1(13),MSG2(14),
     +        MSG3(14),OPTFIL(81)
      INTEGER OPEN,GETARG,CREATE,ZGTCMD
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      DATA (MSG1(FD),FD=1,13)/73,110,112,117,116,32,102,105,
     +     108,101,58,32,129/
      DATA (MSG2(FD),FD=1,14)/79,117,116,112,117,116,32,102,
     +     105,108,101,58,32,129/
      DATA (MSG3(FD),FD=1,14)/79,112,116,105,111,110,32,102,
     +     105,108,101,58,32,129/
 
C  INITIALIZE FORMATTER
      CALL ZINIT
 
C  OBTAIN THE NAME OF THE INPUT FILE AND OPEN IT IF NOT STANDARD INPUT
      STATUS = GETARG(1,SRCFIL,81)
 
C  IF NAME IS NOT FOUND, REQUEST IT FROM THE USER
      IF (STATUS.EQ.-100) THEN
          CALL ZPRMPT(MSG1)
          STATUS = ZGTCMD(SRCFIL,0)
      END IF
 
      FD = OPEN(SRCFIL,0)
 
C  CHECK THAT THE FILE WAS OPENED SUCCESSFULLY
      IF (FD.EQ.-1) CALL ERROR('RF: Unable To Open Input File.')
 
C OBTAIN THE NAME OF THE OUTPUT FILE AND CREATE IT IF NOT STANDARD
C OUTPUT FILE DESCRIPTOR OF OUTPUT FILE IS IN COMMON CPAGE
      STATUS = GETARG(2,OUTFIL,81)
 
C  IF NAME IS NOT FOUND, REQUEST IT FROM THE USER
      IF (STATUS.EQ.-100) THEN
          CALL ZPRMPT(MSG2)
          STATUS = ZGTCMD(OUTFIL,0)
      END IF
 
      FDOUT = CREATE(OUTFIL,1)
 
C  CHECK THAT THE FILE WAS OPENED SUCCESSFULLY
      IF (FDOUT.EQ.-1) CALL ERROR('RF: Unable To Create Output File.')
 
      CALL FINIT
      STATUS = GETARG(3,OPTFIL,81)
      IF (STATUS.EQ.-100) THEN
          CALL ZPRMPT(MSG3)
          STATUS = ZGTCMD(OPTFIL,0)
      END IF
      IF (STATUS.GT.0) THEN
        IF(OPTFIL(1) .NE. CCHAR) THEN
          FDOPT = OPEN(OPTFIL,0)
          IF (FDOPT.NE.-1) THEN
              CALL MAINSB(FDOPT,.FALSE.)
          ELSE
              CALL CANT(OPTFIL)
              CALL ERROR('[ISTRF Error Termination].')
          END IF
        ELSE
          CALL COMAND(OPTFIL)
        ENDIF
      END IF
 
      DO 100 I = 4,10
          STATUS = GETARG(I,OPTFIL,81)
          IF (STATUS.NE.-100) THEN
              IF (STATUS.GT.0) THEN
                IF(OPTFIL(1) .NE. CCHAR) THEN
                  FDOPT = OPEN(OPTFIL,0)
                  IF (FDOPT.NE.-1) THEN
                      CALL MAINSB(FDOPT,.FALSE.)
                  ELSE
                      CALL CANT(OPTFIL)
                      CALL ERROR('[ISTRF Error Termination].')
                  END IF
                ELSE
                  CALL COMAND(OPTFIL)
                ENDIF
              END IF
          END IF
  100 CONTINUE
 
C  CALL FORMATTER
      CALL MAINSB(FD,.TRUE.)
 
C  SAY FAREWELL
      IF (NOWARN.EQ.0) THEN
          CALL ZMESS('[ISTRF Normal Termination].',1)
          CALL ZQUIT(-2)
      ELSE
          CALL ZMESS('[ISTRF Warnings Reported].',1)
          CALL ZQUIT(-1002)
      END IF
 
      END
C------------------------------------------------
C
C  MAIN SUBROUTINE. READ IN LINES AND PROCESS THEM EITHER
C  BY CALLING COMAND (COMMAND LINES) OR TEXT (NON-COMMAND LINES).
C  HANDLE POPPING UP THE INCLUDE FILE STACK AS WELL.
C
      SUBROUTINE MAINSB(FD,ENDIS)
 
      LOGICAL FLAG,TERMIN,ENDIS
      INTEGER FD,INBUF(400),NGETLN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER INFILE(8)
      INTEGER LEVEL
      COMMON /RFIO/ INFILE, LEVEL
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
      SAVE
 
      DATA FLAG/.TRUE./
 
      IF (FLAG) THEN
          ATEND = .FALSE.
          FLAG = .FALSE.
      END IF
      LEGEN = ENDIS
 
      INFILE(1) = FD
      LEVEL = 1
  100 CONTINUE
 
      IF (LEVEL.GT.0) THEN
  200     CONTINUE
          IF (NGETLN(INBUF,INFILE(LEVEL)).NE.-100) THEN
              IF (INBUF(1).EQ.CCHAR) THEN
                  CALL COMAND(INBUF)
              ELSE
                  CALL TEXT(INBUF)
              END IF
              GO TO 200
          END IF
          IF (LEVEL.GT.1 .AND. INFILE(LEVEL).GE.
     +        0) CALL CLOSE(INFILE(LEVEL))
          LEVEL = LEVEL - 1
          GO TO 100
      END IF
 
      CALL BRK
      IF (PLVAL.LE.100 .AND. (LINENO.GT.0.OR.OUTP.GT.0))
     +    CALL SPACE(20000)
 
      END
C----------------------------------------
C
C  JUSTIFY UNPROCESSED TEXT ON A SINGLE LINE
C
      SUBROUTINE DOCL(LINE)
 
      INTEGER LINE(*)
      INTEGER BUFFER(0:134),TEMP(134)
      INTEGER GFIELD
      INTEGER LENT,I,WIDTH,LEFT,RIGHT
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      DO 100 I = 0,RMVAL
          BUFFER(I) = 32
  100 CONTINUE
 
      I = 1
      WIDTH = RMVAL - INVAL + 1
      LEFT = 1
      RIGHT = RMVAL - INVAL + 1
 
      LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
      IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,1,BUFFER)
      LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
      IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,2,BUFFER)
      LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
      IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,3,BUFFER)
 
      BUFFER(RMVAL+1) = 129
 
      CALL PUT(BUFFER)
 
      END
C-----------------------------------------------------------------
C
      SUBROUTINE BOLD2(BUF,TBUF)
 
      INTEGER J
      INTEGER BUF(*),TBUF(*)
      INTEGER LENGTH
 
      TBUF(1) = -50
      CALL SCOPY(BUF,1,TBUF,2)
      J = LENGTH(TBUF)
      IF (TBUF(J).NE.10) J = J + 1
      TBUF(J) = -51
      TBUF(J+1) = 10
      TBUF(J+2) = 129
      CALL SCOPY(TBUF,1,BUF,1)
 
      END
C-----------------------------------------------------------------
C
C  BOLD A PIECE OF TEXT, USE TBUF AS A TEMPORARY BUFFER BUT
C  RETURN THE EMBOLDENED TEXT IN 'BUF'.
C  IF NORMAL BOLD IS BEING USED THEN OVERPRINT EACH CHARACTER
C  WITH ITSELF (USING BACKSPACE), OTHERWISE JUST ADD THE
C  TURN ON AND OFF COMMANDS....
C
C
      SUBROUTINE BOLD(BUF,TBUF)
 
      INTEGER I,J
      INTEGER BUF(*),TBUF(*)
      INTEGER LENGTH
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      IF (EMBEDB) THEN
          TBUF(1) = CHBBED(1)
          TBUF(2) = CHBBED(2)
          CALL SCOPY(BUF,1,TBUF,3)
          J = LENGTH(TBUF)
          IF (TBUF(J).NE.10) J = J + 1
          TBUF(J) = CHBBED(3)
          TBUF(J+1) = CHBBED(4)
          TBUF(J+2) = 10
          TBUF(J+3) = 129
      ELSE
 
          J = 1
          I = 1
  100     CONTINUE
          IF (BUF(I).NE.10) THEN
              TBUF(J) = BUF(I)
              J = J + 1
              IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +            BUF(I).NE.8 .AND. BUF(I).NE.-20 .AND.
     +            BUF(I).NE.-10 .AND. BUF(I).NE.-11) THEN
 
                  TBUF(J) = 8
                  TBUF(J+1) = BUF(I)
                  J = J + 2
 
              END IF
              I = I + 1
              GO TO 100
          END IF
          TBUF(J) = 10
          TBUF(J+1) = 129
 
      END IF
 
      CALL SCOPY(TBUF,1,BUF,1)
 
      END
C------------------------------------------------
      SUBROUTINE BRK
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
      SAVE
 
      IF (OUTP.GT.0) THEN
          OUTBUF(OUTP) = 10
          OUTBUF(OUTP+1) = 129
          CALL PUT(OUTBUF)
      END IF
 
      OUTP = 0
      OUTW = 0
      OUTWDS = 0
 
      END
C------------------------------------------------
      SUBROUTINE CENTER(BUF)
 
      INTEGER BUF(*)
      INTEGER WIDTH
      INTRINSIC MAX
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      TIVAL = MAX((RMVAL+TIVAL-WIDTH(BUF))/2,0)
 
      END
C------------------------------------------------
      SUBROUTINE COMAND(BUF)
 
      INTEGER BUF(*),NAME(134),DEFN(400)
      INTEGER COMTYP,GETVAL,GETWRD,OPEN,LENGTH,CREATE
      INTEGER ARGTYP,CT,SPVAL,VAL,I,COMVAL,J
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER INFILE(8)
      INTEGER LEVEL
      COMMON /RFIO/ INFILE, LEVEL
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER NR(52)
      COMMON /CNR/ NR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      LOGICAL BARFLG, ENDBAR, DELFLG
      INTEGER BARCHR, DELCHR, FSCHAR
      COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
      SAVE
 
      CT = COMTYP(BUF,DEFN)
      IF (CT.EQ.0) THEN
          NOWARN = NOWARN + 1
          CALL ZCHOUT('[ISTRF: WARNING - Unknown command: .',2)
          CALL ZPTMES(BUF,2)
      ELSE IF (CT.NE.51) THEN
          CALL DOESC(BUF,NAME,132)
 
          I = 1
  100     CONTINUE
          IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +        BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
              I = I + 1
              GO TO 100
          END IF
          VAL = GETVAL(BUF,I,ARGTYP)
          IF (CT.EQ.36) THEN
              COMVAL = GETVAL(BUF,I,ARGTYP)
              IF (VAL.LT.COMVAL) THEN
                  RETURN
              ELSE
                  CALL SKIPBL(BUF,I)
                  J = I
  200             CONTINUE
                  IF (J.LE.132) THEN
                      BUF(J-I+1) = BUF(J)
                      J = J + 1
                      GO TO 200
                  END IF
                  CT = COMTYP(BUF,DEFN)
                  IF (CT.EQ.0) THEN
                      RETURN
                  ELSE
                      I = 1
  300                 CONTINUE
                      IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
                          I = I + 1
                          GO TO 300
                      END IF
                      VAL = GETVAL(BUF,I,ARGTYP)
                  END IF
              END IF
 
          ELSE IF (CT.EQ.38) THEN
              COMVAL = GETVAL(BUF,I,ARGTYP)
              IF (VAL.NE.COMVAL) THEN
                  RETURN
              ELSE
                  CALL SKIPBL(BUF,I)
                  J = I
  400             CONTINUE
                  IF (J.LE.132) THEN
                      BUF(J-I+1) = BUF(J)
                      J = J + 1
                      GO TO 400
                  END IF
                  CT = COMTYP(BUF,DEFN)
                  IF (CT.EQ.0) THEN
                      RETURN
                  ELSE
                      I = 1
  500                 CONTINUE
                      IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
                          I = I + 1
                          GO TO 500
                      END IF
 
                      VAL = GETVAL(BUF,I,ARGTYP)
                  END IF
              END IF
 
          ELSE IF (CT.EQ.39) THEN
              COMVAL = GETVAL(BUF,I,ARGTYP)
              IF (VAL.GT.COMVAL) THEN
                  RETURN
              ELSE
                  CALL SKIPBL(BUF,I)
                  J = I
  600             CONTINUE
                  IF (J.LE.132) THEN
                      BUF(J-I+1) = BUF(J)
                      J = J + 1
                      GO TO 600
                  END IF
                  CT = COMTYP(BUF,DEFN)
                  IF (CT.EQ.0) THEN
                      RETURN
                  ELSE
                      I = 1
  700                 CONTINUE
                      IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
                          I = I + 1
                          GO TO 700
                      END IF
 
                      VAL = GETVAL(BUF,I,ARGTYP)
                  END IF
              END IF
          END IF
 
          IF (CT.EQ.-1) THEN
              CALL EVAL(BUF,DEFN)
          ELSE IF (CT.EQ.37) THEN
              CALL BRK
              CALL GETTL(BUF,LINEXX,LINLIM)
              CALL DOCL(LINEXX)
          ELSE IF (CT.EQ.1) THEN
              CALL BRK
              FILL = -2
          ELSE IF (CT.EQ.2) THEN
              CALL BRK
              FILL = -3
          ELSE IF (CT.EQ.3) THEN
              CALL BRK
          ELSE IF (CT.EQ.4) THEN
              CALL SET(LSVAL,VAL,ARGTYP,1,1,20000)
          ELSE IF (CT.EQ.10) THEN
              CALL BRK
              CALL SET(CEVAL,VAL,ARGTYP,1,0,20000)
          ELSE IF (CT.EQ.11) THEN
              CUVAL = 0
              CALL SET(ULVAL,VAL,ARGTYP,0,1,20000)
          ELSE IF (CT.EQ.16) THEN
              CALL SET(BOVAL,VAL,ARGTYP,0,1,20000)
          ELSE IF (CT.EQ.12) THEN
              CALL GETTL(BUF,EHEAD,EHLIM)
              CALL GETTL(BUF,OHEAD,OHLIM)
          ELSE IF (CT.EQ.13) THEN
              CALL GETTL(BUF,EFOOT,EFLIM)
              CALL GETTL(BUF,OFOOT,OFLIM)
          ELSE IF (CT.EQ.5) THEN
              CALL BRK
              IF (LINENO.GT.0) CALL SPACE(20000)
              CALL SET(CURPAG,VAL,ARGTYP,CURPAG+1,-20000,20000)
              NEWPAG = CURPAG
          ELSE IF (CT.EQ.6) THEN
              CALL SET(SPVAL,VAL,ARGTYP,1,0,20000)
              CALL SPACE(SPVAL)
          ELSE IF (CT.EQ.7) THEN
              CALL BRK
              CALL SET(INVAL,VAL,ARGTYP,0,0,RMVAL-1)
              TIVAL = INVAL
              NR(51) = INVAL
          ELSE IF (CT.EQ.8) THEN
              CALL SET(RMVAL,VAL,ARGTYP,65,TIVAL+1,20000)
          ELSE IF (CT.EQ.9) THEN
              CALL BRK
              CALL SET(TIVAL,VAL,ARGTYP,0,0,RMVAL)
          ELSE IF (CT.EQ.14) THEN
              CALL SET(PLVAL,VAL,ARGTYP,66,
     +                 M1VAL+M2VAL+M3VAL+M4VAL+1,20000)
              BOTTOM = PLVAL - M3VAL - M4VAL
          ELSE IF (CT.EQ.15) THEN
              CALL SET(OFFSET,VAL,ARGTYP,0,0,RMVAL-1)
          ELSE IF (CT.EQ.17) THEN
              CALL SET(M1VAL,VAL,ARGTYP,3,0,PLVAL-M2VAL-M3VAL-M4VAL-1)
          ELSE IF (CT.EQ.18) THEN
              CALL SET(M2VAL,VAL,ARGTYP,2,0,PLVAL-M1VAL-M3VAL-M4VAL-1)
          ELSE IF (CT.EQ.19) THEN
              CALL SET(M3VAL,VAL,ARGTYP,2,0,PLVAL-M1VAL-M2VAL-M4VAL-1)
              BOTTOM = PLVAL - M3VAL - M4VAL
          ELSE IF (CT.EQ.20) THEN
              CALL SET(M4VAL,VAL,ARGTYP,3,0,PLVAL-M1VAL-M2VAL-M3VAL-1)
              BOTTOM = PLVAL - M3VAL - M4VAL
          ELSE
              GO TO 800
          END IF
          RETURN
C
C  AVOID THE IBM LIMIT OF 25 ELSE-IF BLOCKS
C
 800      IF (CT.EQ.21) THEN
              CALL GETTL(BUF,EHEAD,EHLIM)
          ELSE IF (CT.EQ.22) THEN
              CALL GETTL(BUF,OHEAD,OHLIM)
          ELSE IF (CT.EQ.23) THEN
              CALL GETTL(BUF,EFOOT,EFLIM)
          ELSE IF (CT.EQ.24) THEN
              CALL GETTL(BUF,OFOOT,OFLIM)
          ELSE IF (CT.EQ.25) THEN
              CCHAR = ARGTYP
              IF (CCHAR.EQ.129 .OR. CCHAR.EQ.10) CCHAR = 46
              IF ((LINENO+VAL).GT.BOTTOM .AND.
     +            LINENO.LE.BOTTOM) THEN
                  CALL SPACE(VAL)
                  LINENO = 0
              END IF
          ELSE IF (CT.EQ.26) THEN
              IF ((LINENO+VAL).GT.BOTTOM .AND.
     +            LINENO.LE.BOTTOM) THEN
                  CALL SPACE(VAL)
                  LINENO = 0
              END IF
          ELSE IF (CT.EQ.27) THEN
              CALL SET(BSVAL,VAL,ARGTYP,1,0,20000)
          ELSE IF (CT.EQ.28) THEN
              RJUST = -2
          ELSE IF (CT.EQ.29) THEN
              RJUST = -3
          ELSE IF (CT.EQ.30) THEN
              IF (GETWRD(BUF,I,NAME).NE.0) THEN
                  IF (LEVEL+1.GT.8) CALL REMARK(
     +                'RF: SO REQUESTS NESTED TOO DEEPLY (COMAND).')
                  INFILE(LEVEL+1) = OPEN(NAME,0)
                  IF (INFILE(LEVEL+1).NE.-1) LEVEL = LEVEL + 1
              END IF
          ELSE IF (CT.EQ.31) THEN
              ULVAL = 0
              CALL SET(CUVAL,VAL,ARGTYP,0,1,20000)
          ELSE IF (CT.EQ.32) THEN
              CALL DODEF(BUF,INFILE(LEVEL))
          ELSE IF (CT.EQ.34) THEN
              IF (GETWRD(BUF,I,NAME).NE.0) THEN
                  IF (NAME(1).LT.65 .OR.
     +                (NAME(1).GT.90.AND.NAME(1).LT.97) .OR.
     +                NAME(1).GT.122) CALL REMARK
     +                ('RF: INVALID NUMBER REGISTER NAME (COMAND).')
                  VAL = GETVAL(BUF,I,ARGTYP)
                  IF (NAME(1).GE.97 .AND. NAME(1).LE.122) THEN
                      CALL SET(NR(NAME(1)-97+1),VAL,ARGTYP,0,
     +                         -20000,20000)
                  ELSE
                      CALL SET(NR(NAME(1)-65+27),VAL,ARGTYP,0,
     +                         -20000,20000)
                  END IF
              END IF
          ELSE IF (CT.EQ.35) THEN
              IF (ARGTYP.EQ.45) THEN
                  SPVAL = PLVAL
              ELSE
                  SPVAL = 0
              END IF
              CALL SET(SPVAL,VAL,ARGTYP,0,1,BOTTOM)
              IF (SPVAL.GT.LINENO .AND. LINENO.EQ.0) CALL PHEAD
              IF (SPVAL.GT.LINENO) CALL SPACE(SPVAL-LINENO)
          ELSE IF (CT.EQ.40) THEN
              IF (.NOT.BARFLG) THEN
                  BARFLG = .TRUE.
                  ENDBAR = .FALSE.
              END IF
          ELSE IF (CT.EQ.44) THEN
              DELFLG = .TRUE.
          ELSE IF (CT.EQ.41) THEN
              ENDBAR = .TRUE.
          ELSE IF (CT.EQ.42) THEN
              BARCHR = ARGTYP
              IF (BARCHR.EQ.129 .OR. BARCHR.EQ.10) BARCHR = 124
          ELSE IF (CT.EQ.43) THEN
              DELCHR = ARGTYP
              IF (DELCHR.EQ.129 .OR. DELCHR.EQ.
     +            10) DELCHR = 35
          ELSE IF (CT.EQ.45) THEN
              FSCHAR = ARGTYP
              IF (FSCHAR.EQ.129 .OR. FSCHAR.EQ.
     +            10) FSCHAR = 126
          ELSE IF (CT.EQ.46) THEN
              STOPF = .NOT. STOPF
              IF(ARGTYP .EQ. 45) STOPP = .FALSE.
              IF(ARGTYP .EQ.  43) STOPP = .TRUE.
          ELSE IF (CT.EQ.52) THEN
              STOPH = .NOT. STOPH
              IF(ARGTYP .EQ. 45) STOPP = .FALSE.
              IF(ARGTYP .EQ.  43) STOPP = .TRUE.
          ELSE
              GO TO 900
          END IF
          RETURN
C
C  AVOID THE IBM LIMIT OF 25 ELSE-IF BLOCKS
C
 900      IF (CT.EQ.50) THEN
              EMBEDB = .TRUE.
              CALL SKIPBL(BUF,I)
              IF (I.NE.129 .AND. LENGTH(BUF).GE.I+3) THEN
                  CHBBED(1) = BUF(I)
                  CHBBED(2) = BUF(I+1)
                  CHBBED(3) = BUF(I+2)
                  CHBBED(4) = BUF(I+3)
              END IF
          ELSE IF (CT.EQ.48) THEN
              EMBEDB = .FALSE.
          ELSE IF (CT.EQ.49) THEN
              EMBEDU = .TRUE.
              CALL SKIPBL(BUF,I)
              IF (I.NE.129 .AND. LENGTH(BUF).GE.I+3) THEN
                  CHUBED(1) = BUF(I)
                  CHUBED(2) = BUF(I+1)
                  CHUBED(3) = BUF(I+2)
                  CHUBED(4) = BUF(I+3)
              END IF
          ELSE IF (CT.EQ.47) THEN
              EMBEDU = .FALSE.
          ELSE IF (CT.EQ.53) THEN
              CALL BRK
              IF(.NOT. NORMFD) THEN
                NORMFD = .TRUE.
                CALL CLOSE(FDOUT)
              ELSE
                FDSAVE = FDOUT
              ENDIF
 
              FDOUT = -1
              IF (GETWRD(BUF,I,NAME).NE.0) FDOUT = CREATE(NAME,1)
              IF(FDOUT .NE. -1) THEN
                NORMFD = .FALSE.
              ELSE
                CALL CANT(NAME)
                CALL ERROR('[ISTRF: Error Termination].')
              ENDIF
          ELSE IF (CT.EQ.54) THEN
              CALL BRK
              IF(.NOT. NORMFD) THEN
                NORMFD = .TRUE.
                CALL CLOSE(FDOUT)
                FDOUT = FDSAVE
              ENDIF
          END IF
      END IF
 
      END
C------------------------------------------------
      INTEGER FUNCTION COMTYP(BUF,DEFN)
 
      INTEGER BUF(*),DEFN(*)
 
      INTEGER NAME(13),MAXCMD
      PARAMETER (MAXCMD=54)
      INTEGER I,GETWRD,VALUES(3,MAXCMD)
      LOGICAL LUDEF
      SAVE VALUES
 
      DATA (VALUES(I,1),I=1,3)/115,112,6/
      DATA (VALUES(I,2),I=1,3)/110,102,2/
      DATA (VALUES(I,3),I=1,3)/98,114,3/
      DATA (VALUES(I,4),I=1,3)/108,115,4/
      DATA (VALUES(I,5),I=1,3)/98,112,5/
      DATA (VALUES(I,6),I=1,3)/102,105,1/
      DATA (VALUES(I,7),I=1,3)/105,110,7/
      DATA (VALUES(I,8),I=1,3)/114,109,8/
      DATA (VALUES(I,9),I=1,3)/116,105,9/
      DATA (VALUES(I,10),I=1,3)/99,101,10/
      DATA (VALUES(I,11),I=1,3)/99,108,37/
      DATA (VALUES(I,12),I=1,3)/117,108,11/
      DATA (VALUES(I,13),I=1,3)/104,101,12/
      DATA (VALUES(I,14),I=1,3)/102,111,13/
      DATA (VALUES(I,15),I=1,3)/112,108,14/
      DATA (VALUES(I,16),I=1,3)/112,111,15/
      DATA (VALUES(I,17),I=1,3)/98,100,16/
      DATA (VALUES(I,18),I=1,3)/109,49,17/
      DATA (VALUES(I,19),I=1,3)/109,50,18/
      DATA (VALUES(I,20),I=1,3)/109,51,19/
      DATA (VALUES(I,21),I=1,3)/109,52,20/
      DATA (VALUES(I,22),I=1,3)/101,104,21/
      DATA (VALUES(I,23),I=1,3)/111,104,22/
      DATA (VALUES(I,24),I=1,3)/101,102,23/
      DATA (VALUES(I,25),I=1,3)/111,102,24/
      DATA (VALUES(I,26),I=1,3)/99,99,25/
      DATA (VALUES(I,27),I=1,3)/110,101,26/
      DATA (VALUES(I,28),I=1,3)/98,115,27/
      DATA (VALUES(I,29),I=1,3)/106,117,28/
      DATA (VALUES(I,30),I=1,3)/110,106,29/
      DATA (VALUES(I,31),I=1,3)/115,111,30/
      DATA (VALUES(I,32),I=1,3)/99,117,31/
      DATA (VALUES(I,33),I=1,3)/100,101,32/
      DATA (VALUES(I,34),I=1,3)/101,110,33/
      DATA (VALUES(I,35),I=1,3)/110,114,34/
      DATA (VALUES(I,36),I=1,3)/115,116,35/
      DATA (VALUES(I,37),I=1,3)/105,102,36/
      DATA (VALUES(I,38),I=1,3)/105,101,38/
      DATA (VALUES(I,39),I=1,3)/105,108,39/
      DATA (VALUES(I,40),I=1,3)/98,98,40/
      DATA (VALUES(I,41),I=1,3)/101,98,41/
      DATA (VALUES(I,42),I=1,3)/98,99,42/
      DATA (VALUES(I,43),I=1,3)/100,98,44/
      DATA (VALUES(I,44),I=1,3)/100,99,43/
      DATA (VALUES(I,45),I=1,3)/102,115,45/
      DATA (VALUES(I,46),I=1,3)/112,102,46/
      DATA (VALUES(I,47),I=1,3)/110,117,47/
      DATA (VALUES(I,48),I=1,3)/110,98,48/
      DATA (VALUES(I,49),I=1,3)/105,117,49/
      DATA (VALUES(I,50),I=1,3)/105,98,50/
      DATA (VALUES(I,51),I=1,3)/110,111,51/
      DATA (VALUES(I,52),I=1,3)/112,104,52/
      DATA (VALUES(I,53),I=1,3)/115,102,53/
      DATA (VALUES(I,54),I=1,3)/122,102,54/
 
      I = 2
      I = GETWRD(BUF,I,NAME)
      IF (I.GT.2) NAME(3) = 129
 
      IF (LUDEF(NAME,DEFN)) THEN
          COMTYP = -1
      ELSE
          COMTYP = 0
          DO 100 I = 1,MAXCMD
              IF (BUF(2).EQ.VALUES(1,I) .AND.
     +            BUF(3).EQ.VALUES(2,I)) GO TO 200
  100     CONTINUE
          RETURN
  200     COMTYP = VALUES(3,I)
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE DODEF(BUF,FD)
 
      INTEGER BUF(*)
      INTEGER FD
      INTEGER NAME(13),DEFN(400)
      INTEGER I,JUNK
      INTEGER GETWRD,ADDSTR,ADDSET,NGETLN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      I = 1
      JUNK = GETWRD(BUF,I,NAME)
      I = GETWRD(BUF,I,NAME)
      IF (I.EQ.0) CALL REMARK(
     +                 'RF: MISSING NAME IN REQUEST DEFINITION (DODEF).'
     +                        )
      IF (I.GT.2) NAME(3) = 129
 
      I = 1
  100 CONTINUE
      IF (NGETLN(BUF,FD).NE.-100) THEN
          IF (BUF(1).NE.CCHAR .OR. BUF(2).NE.101 .OR.
     +        BUF(3).NE.110) THEN
              JUNK = ADDSTR(BUF,DEFN,I,400)
              GO TO 100
          END IF
      END IF
 
      IF (ADDSET(129,DEFN,I,400).EQ.-3)
     +    CALL REMARK('RF: DEFINITION TOO LONG (DODEF).')
      CALL ENTDEF(NAME,DEFN)
 
      END
C------------------------------------------------
      SUBROUTINE DOESC(BUF,TBUF,SIZE)
 
      INTEGER BUF(*),TBUF(*)
      INTEGER SIZE,ITOA
      INTEGER I,J
      INTEGER ITOC
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      LOGICAL BARFLG, ENDBAR, DELFLG
      INTEGER BARCHR, DELCHR, FSCHAR
      COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER NR(52)
      COMMON /CNR/ NR
 
      SAVE
 
      J = 1
      I = 1
  100 CONTINUE
 
      IF (BUF(I).NE.129 .AND. J.LT.SIZE) THEN
          IF (BUF(I).NE.64) THEN
              IF (BUF(I).EQ.FSCHAR) THEN
                  TBUF(J) = -20
              ELSE
                  TBUF(J) = BUF(I)
              END IF
              J = J + 1
 
          ELSE IF (BUF(I+1).EQ.64) THEN
              TBUF(J) = 64
              J = J + 1
              I = I + 1
 
          ELSE IF (BUF(I+1).EQ.110 .AND.
     +             ((BUF(I+2).GE.97.AND.BUF(I+2).LE.122).OR.
     +             (BUF(I+2).GE.65.AND.BUF(I+2).LE.90))) THEN
              IF (BUF(I+2).GE.97 .AND. BUF(I+2).LE.122) THEN
                  J = J + ITOC(NR(BUF(I+2)-97+1),TBUF(J),SIZE-J-1)
              ELSE
                  J = J + ITOC(NR(BUF(I+2)-65+27),TBUF(J),SIZE-J-1)
              END IF
              I = I + 2
 
          ELSE IF (BUF(I+1).EQ.97 .AND.
     +             ((BUF(I+2).GE.97.AND.BUF(I+2).LE.122).OR.
     +             (BUF(I+2).GE.65.AND.BUF(I+2).LE.90))) THEN
              IF (BUF(I+2).GE.97 .AND. BUF(I+2).LE.122) THEN
                  J = J + ITOA(NR(BUF(I+2)-97+1),TBUF(J))
              ELSE
                  J = J + ITOA(NR(BUF(I+2)-65+27),TBUF(J))
              END IF
              I = I + 2
 
          ELSE IF (BUF(I+1).EQ.FSCHAR) THEN
              TBUF(J) = FSCHAR
              J = J + 1
              I = I + 1
          ELSE
 
              TBUF(J) = BUF(I)
              J = J + 1
 
          END IF
 
          I = I + 1
          GO TO 100
      END IF
 
      TBUF(J) = 129
      CALL SCOPY(TBUF,1,BUF,1)
 
      END
C------------------------------------------------
      SUBROUTINE DOTABS(BUF,TBUF,SIZE)
 
      INTEGER BUF(*),TBUF(*)
      INTEGER SIZE
      INTEGER I,J
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      J = 1
      I = 1
  100 CONTINUE
      IF (BUF(I).NE.129 .AND. J.LT.SIZE) THEN
          IF (BUF(I).EQ.9) THEN
  200         CONTINUE
              IF (J.LT.SIZE) THEN
                  TBUF(J) = 32
                  J = J + 1
                  IF (TABS(J).NE.-2.AND.J.LE.400) GO TO 200
              END IF
          ELSE
              TBUF(J) = BUF(I)
              J = J + 1
          END IF
          I = I + 1
          GO TO 100
      END IF
 
      TBUF(J) = 129
      CALL SCOPY(TBUF,1,BUF,1)
 
      END
C------------------------------------------------
      SUBROUTINE EVAL(BUF,DEFN)
 
      INTEGER BUF(*),DEFN(*)
      INTEGER I,J,K,ARGPTR(10)
      INTEGER LENGTH
 
      DO 100 J = 1,10
          ARGPTR(J) = 1
  100 CONTINUE
 
      BUF(1) = 129
      I = 2
      DO 400 J = 1,10
          CALL SKIPBL(BUF,I)
          IF (BUF(I).EQ.10 .OR. BUF(I).EQ.129) THEN
              GO TO 600
          ELSE
              ARGPTR(J) = I
              IF (BUF(I).EQ.34) THEN
                  ARGPTR(J) = ARGPTR(J) + 1
                  I = I + 1
  200             CONTINUE
                  IF (BUF(I).NE.34) THEN
                      IF (BUF(I).EQ.10 .OR. BUF(I).EQ.129) THEN
                          GO TO 500
                      ELSE
                          I = I + 1
                          GO TO 200
                      END IF
                  END IF
              ELSE
  300             CONTINUE
 
                  IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +                BUF(I).NE.10 .AND. BUF(I).NE.129) THEN
                      I = I + 1
                      GO TO 300
                  END IF
              END IF
 
              BUF(I) = 129
              I = I + 1
          END IF
  400 CONTINUE
 
      GO TO 600
  500 CALL REMARK('RF: MISSING DOUBLE QUOTE (EVAL).')
      RETURN
 
  600 CONTINUE
      K = LENGTH(DEFN)
  700 CONTINUE
      IF (K.GT.1) THEN
          IF (DEFN(K-1).NE.36) THEN
              CALL PUTBAK(DEFN(K))
          ELSE IF (DEFN(K).LT.48 .OR. DEFN(K).GT.57) THEN
              CALL PUTBAK(DEFN(K))
          ELSE
              I = DEFN(K) - 48 + 1
              I = ARGPTR(I)
              CALL PBSTR(BUF(I))
              K = K - 1
          END IF
          K = K - 1
          GO TO 700
      END IF
 
      IF (K.GT.0) CALL PUTBAK(DEFN(K))
 
      END
C------------------------------------------------
C
      SUBROUTINE FINIT
 
      INTEGER I
      INTRINSIC MOD
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER BP
      INTEGER BUF(400)
      COMMON /CDEFIO/ BP, BUF
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER NR(52)
      COMMON /CNR/ NR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      LOGICAL BARFLG, ENDBAR, DELFLG
      INTEGER BARCHR, DELCHR, FSCHAR
      COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
      SAVE
 
      INVAL = 0
      RMVAL = 65
      TIVAL = 0
      LSVAL = 1
      FILL = -2
      CEVAL = 0
      ULVAL = 0
      BOVAL = 0
      CCHAR = 46
      TJUST(1) = 1
      TJUST(2) = 2
      TJUST(3) = 3
      BSVAL = 0
      RJUST = -2
      CUVAL = 0
      DO 100 I = 1,400
          IF (MOD(I,8).EQ.1) THEN
              TABS(I) = -2
          ELSE
              TABS(I) = -3
          END IF
  100 CONTINUE
 
      NORMFD = .TRUE.
      ENDBAR = .FALSE.
      DELFLG = .FALSE.
      BARFLG = .FALSE.
      BARCHR = 124
      DELCHR = 35
      FSCHAR = 126
      LINENO = 0
      CURPAG = 0
      NEWPAG = 1
      PLVAL = 66
      M1VAL = 3
      M2VAL = 2
      M3VAL = 2
      M4VAL = 3
      BOTTOM = PLVAL - M3VAL - M4VAL
      EHEAD(1) = 10
      EHEAD(2) = 129
      OHEAD(1) = 10
      OHEAD(2) = 129
      EFOOT(1) = 10
      EFOOT(2) = 129
      OFOOT(1) = 10
      OFOOT(2) = 129
      EHLIM(1) = INVAL
      EHLIM(2) = RMVAL
      OHLIM(1) = INVAL
      OHLIM(2) = RMVAL
      EFLIM(1) = INVAL
      EFLIM(2) = RMVAL
      OFLIM(1) = INVAL
      OFLIM(2) = RMVAL
      STOPH = .FALSE.
      STOPF = .FALSE.
      STOPP = .TRUE.
      FRSTPG = 0
      LASTPG = 20000
      PRINT = -2
      OFFSET = 0
      OUTP = 0
      OUTW = 0
      OUTWDS = 0
      CALL DSINIT
      BP = 0
      NOWARN = 0
 
      DO 200 I = 1,52
          NR(I) = 0
  200 CONTINUE
C
C  INITIALISE IN-LINE COMMAND EXPANSION
C
      EMBEDU = .FALSE.
      CHUBED(1) = 60
      CHUBED(2) = 95
      CHUBED(3) = 95
      CHUBED(4) = 62
      EMBEDB = .FALSE.
      CHBBED(1) = 60
      CHBBED(2) = 45
      CHBBED(3) = 45
      CHBBED(4) = 62
 
      END
C------------------------------------------------
      SUBROUTINE GETTL(BUF,TTL,LIM)
 
      INTEGER BUF(*),TTL(*)
      INTEGER I,LIM(2)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      I = 1
  100 CONTINUE
      IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
     +    BUF(I).NE.10) THEN
          I = I + 1
          GO TO 100
      END IF
 
      CALL SKIPBL(BUF,I)
      CALL SCOPY(BUF,I,TTL,1)
      LIM(1) = INVAL
      LIM(2) = RMVAL
 
      END
C------------------------------------------------
      INTEGER FUNCTION GETVAL(BUF,I,ARGTYP)
 
      INTEGER BUF(*)
      INTEGER I,ARGTYP
      INTEGER CTOI
 
      CALL SKIPBL(BUF,I)
      ARGTYP = BUF(I)
      IF (ARGTYP.EQ.43 .OR. ARGTYP.EQ.45) I = I + 1
      IF (BUF(I).EQ.34) THEN
          GETVAL = -1
  100     CONTINUE
          I = I + 1
          GETVAL = GETVAL + 1
          IF (BUF(I).NE.34 .AND. BUF(I).NE.129 .AND.
     +        BUF(I).NE.10) GO TO 100
      ELSE
          GETVAL = CTOI(BUF,I)
      END IF
 
      END
C------------------------------------------------
      INTEGER FUNCTION GETWRB(IN,I,OUT)
 
      INTEGER IN(*),OUT(*)
      INTEGER I,J
 
      J = 1
  100 CONTINUE
      IF (IN(I).NE.129 .AND. IN(I).NE.32 .AND. IN(I).NE.9 .AND.
     +    IN(I).NE.10) THEN
          OUT(J) = IN(I)
          I = I + 1
          J = J + 1
          GO TO 100
      END IF
  200 CONTINUE
 
      IF (IN(I).EQ.32) THEN
          OUT(J) = 32
          I = I + 1
          J = J + 1
          GO TO 200
      END IF
      OUT(J) = 129
      GETWRB = J - 1
 
      END
C------------------------------------------------
C
C  COPY A SUB-FIELD OF AT MOST N CHARACTERS FROM BUF
C  TO TEMP. START AT BUF(I).
C
      INTEGER FUNCTION GFIELD(BUF,I,N,TEMP,DELIM)
 
      INTEGER BUF(*),TEMP(*),DELIM
      INTEGER I,J,N
 
      J = 1
      IF (N.GT.0) THEN
          IF (BUF(I).EQ.DELIM) I = I + 1
  100     CONTINUE
          IF (BUF(I).NE.DELIM .AND. BUF(I).NE.129 .AND.
     +        BUF(I).NE.10 .AND. J.LE.N) THEN
              TEMP(J) = BUF(I)
              J = J + 1
              I = I + 1
              GO TO 100
          END IF
      END IF
 
      TEMP(J) = 129
      GFIELD = J - 1
  200 CONTINUE
      IF (BUF(I).NE.DELIM .AND. BUF(I).NE.129 .AND.
     +    BUF(I).NE.10) THEN
          I = I + 1
          GO TO 200
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE JCOPY(FROM,I,TO,J)
 
      INTEGER FROM(*),TO(*)
      INTEGER I,J,K1,K2
 
      K1 = I
      K2 = J
  100 CONTINUE
      IF (FROM(K1).NE.129) THEN
          TO(K2) = FROM(K1)
          K1 = K1 + 1
          K2 = K2 + 1
          GO TO 100
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE JUSTFY(IN,LEFT,RIGHT,TYPE,OUT)
 
      INTEGER IN(*),OUT(*)
      INTEGER LEFT,RIGHT,TYPE,J,N,WIDTH
      INTRINSIC MAX
 
      N = WIDTH(IN)
      IF (TYPE.EQ.3) THEN
          CALL JCOPY(IN,1,OUT,RIGHT-N)
      ELSE IF (TYPE.EQ.2) THEN
          J = MAX((RIGHT+LEFT-N)/2,LEFT)
          CALL JCOPY(IN,1,OUT,J)
      ELSE
          CALL JCOPY(IN,1,OUT,LEFT)
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE LEADBL(BUF)
 
      INTEGER BUF(*)
      INTEGER I,J
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      CALL BRK
      I = 1
  100 CONTINUE
      IF (BUF(I).EQ.32) THEN
          I = I + 1
          GO TO 100
      END IF
      IF (BUF(I).NE.10) TIVAL = TIVAL + I - 1
 
      J = 1
      IF (J.NE.I) THEN
  200     CONTINUE
          BUF(J) = BUF(I)
          I = I + 1
          J = J + 1
          IF (BUF(J-1).NE.129) GO TO 200
      END IF
 
      END
C------------------------------------------------
      INTEGER FUNCTION NGETCH(C,FD)
 
      INTEGER C,FD
      INTEGER GETCH
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER BP
      INTEGER BUF(400)
      COMMON /CDEFIO/ BP, BUF
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER INFILE(8)
      INTEGER LEVEL
      COMMON /RFIO/ INFILE, LEVEL
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
      SAVE
 
      IF (BP.GT.0) THEN
          C = BUF(BP)
          BP = BP - 1
      ELSE
          C = GETCH(C,FD)
      END IF
 
      IF (LEVEL.EQ.1 .AND. C.EQ.-100 .AND. LEGEN) ATEND = .TRUE.
      NGETCH = C
 
      END
C------------------------------------------------
      INTEGER FUNCTION NGETLN(LINE,F)
 
      INTEGER LINE(*),C,NGETCH
      INTEGER F
 
      NGETLN = 0
  100 CONTINUE
      IF (NGETCH(C,F).NE.-100) THEN
          IF (NGETLN.LT.132-1) THEN
              NGETLN = NGETLN + 1
              LINE(NGETLN) = C
          END IF
          IF (C.NE.10) GO TO 100
      END IF
 
      LINE(NGETLN+1) = 129
      IF (NGETLN.EQ.0 .AND. C.EQ.-100) NGETLN = -100
 
      END
C------------------------------------------------
      SUBROUTINE PBSTR(IN)
 
      INTEGER IN(*)
      INTEGER LENGTH
      INTEGER I
 
      DO 100 I = LENGTH(IN),1,-1
          CALL PUTBAK(IN(I))
  100 CONTINUE
 
      END
C------------------------------------------------
      SUBROUTINE PFOOT
 
      INTRINSIC MOD
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
      SAVE
 
      CALL SKIPF(M3VAL)
      IF (M4VAL.GT.0) THEN
          IF (MOD(CURPAG,2).EQ.0) THEN
              CALL PUTTL(EFOOT,EFLIM,CURPAG)
          ELSE
              CALL PUTTL(OFOOT,OFLIM,CURPAG)
          END IF
          CALL SKIPF(M4VAL-1)
      END IF
      IF (STOPF .AND. PRINT.EQ.-2) CALL PRMPT
 
      END
C------------------------------------------------
      SUBROUTINE PHEAD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
      SAVE
      INTRINSIC MOD
 
      CURPAG = NEWPAG
      IF (CURPAG.GE.FRSTPG .AND. CURPAG.LE.LASTPG) THEN
          PRINT = -2
      ELSE
          PRINT = -3
      END IF
 
      IF (STOPH .AND. PRINT.EQ.-2) CALL PRMPT
      NEWPAG = NEWPAG + 1
      IF (M1VAL.GT.0) THEN
          CALL SKIPF(M1VAL-1)
          IF (MOD(CURPAG,2).EQ.0) THEN
              CALL PUTTL(EHEAD,EHLIM,CURPAG)
          ELSE
              CALL PUTTL(OHEAD,OHLIM,CURPAG)
          END IF
      END IF
      CALL SKIPF(M2VAL)
      LINENO = M1VAL + M2VAL + 1
 
      END
C------------------------------------------
      SUBROUTINE PRMPT
 
      INTEGER JUNK
      INTEGER GETLIN
      INTEGER LINE(134)
      INTEGER TELL(32)
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
      SAVE
 
      DATA TELL/84,121,112,101,32,82,69,84,85,82,78,
     +     32,116,111,32,98,101,103,105,110,32,110,
     +     101,119,32,112,97,103,101,58,32,129/
 
      IF (STOPP) CALL ZPRMPT(TELL)
      JUNK = GETLIN(LINE,0)
 
      END
C------------------------------------------------
      SUBROUTINE PUT(BUF)
 
      INTEGER BUF(*)
      INTEGER I,COUNT,NOCHAR,CBFLAG,CUFLAG
      INTRINSIC MIN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      LOGICAL BARFLG, ENDBAR, DELFLG
      INTEGER BARCHR, DELCHR, FSCHAR
      COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
      SAVE
 
      DATA CUFLAG/-3/,CBFLAG/-3/
 
      IF (LINENO.EQ.0 .OR. LINENO.GT.BOTTOM) CALL PHEAD
      IF (PRINT.EQ.-2) THEN
 
          DO 100 I = 1,TIVAL + OFFSET
              CALL PUTCH(32,FDOUT)
  100     CONTINUE
          COUNT = TIVAL
          NOCHAR = TIVAL
 
          I = 1
  200     CONTINUE
          IF (BUF(I).NE.129 .AND. BUF(I).NE.10) THEN
              IF (BUF(I).EQ.-10) THEN
                  IF (EMBEDU) THEN
                      CALL PUTCH(CHUBED(1),FDOUT)
                      CALL PUTCH(CHUBED(2),FDOUT)
                      NOCHAR = NOCHAR + 2
                  ELSE
                      CUFLAG = -2
                  END IF
              ELSE IF (BUF(I).EQ.-11) THEN
                  IF (EMBEDU) THEN
                      CALL PUTCH(CHUBED(3),FDOUT)
                      CALL PUTCH(CHUBED(4),FDOUT)
                      NOCHAR = NOCHAR + 2
                  ELSE
                      CUFLAG = -3
                  END IF
 
              ELSE IF (BUF(I).EQ.-50) THEN
                  IF (EMBEDB) THEN
                      CALL PUTCH(CHBBED(1),FDOUT)
                      CALL PUTCH(CHBBED(2),FDOUT)
                      NOCHAR = NOCHAR + 2
                  ELSE
                      CBFLAG = -2
                  END IF
              ELSE IF (BUF(I).EQ.-51) THEN
                  IF (EMBEDB) THEN
                      CALL PUTCH(CHBBED(3),FDOUT)
                      CALL PUTCH(CHBBED(4),FDOUT)
                      NOCHAR = NOCHAR + 2
                  ELSE
                      CBFLAG = -3
                  END IF
              ELSE
 
                  IF (CUFLAG.EQ.-2) THEN
                      CALL PUTCH(95,FDOUT)
                      CALL PUTCH(8,FDOUT)
                      NOCHAR = NOCHAR + 2
                  END IF
                  IF (CBFLAG.EQ.-2) THEN
                      IF (BUF(I).EQ.-20) THEN
                          CALL PUTCH(32,FDOUT)
                      ELSE
                          CALL PUTCH(BUF(I),FDOUT)
                      END IF
                      CALL PUTCH(8,FDOUT)
                      NOCHAR = NOCHAR + 2
                  END IF
                  IF (BUF(I).EQ.-20) THEN
                      CALL PUTCH(32,FDOUT)
                  ELSE
                      CALL PUTCH(BUF(I),FDOUT)
                  END IF
                  COUNT = COUNT + 1
                  NOCHAR = NOCHAR + 1
              END IF
 
              I = I + 1
              GO TO 200
          END IF
C
C  OBEY THE CHANGE BAR REQUESTS....
C
          IF (DELFLG) THEN
              DO 300 I = COUNT,RMVAL + 3
                  CALL PUTCH(32,FDOUT)
  300         CONTINUE
              CALL PUTCH(DELCHR,FDOUT)
              NOCHAR = NOCHAR + 3 + MAX(0,RMVAL+3-COUNT)
              DELFLG = .FALSE.
          ELSE IF (BARFLG) THEN
              DO 400 I = COUNT,RMVAL + 3
                  CALL PUTCH(32,FDOUT)
  400         CONTINUE
              NOCHAR = NOCHAR + 3 + MAX(0,RMVAL+3-COUNT)
              CALL PUTCH(BARCHR,FDOUT)
          END IF
          IF (ENDBAR) THEN
              ENDBAR = .FALSE.
              BARFLG = .FALSE.
          END IF
          CALL PUTCH(10,FDOUT)
C
C  CHECK THE NUMBER OF CHARACTERS ACTUALLY OUTPUT....
C
          IF (NOCHAR.GT.132) THEN
              NOWARN = NOWARN + 1
              CALL ZCHOUT('[ISTRF - WARNING: Line .',2)
              CALL ZPTINT(LINENO,1,2)
              CALL ZCHOUT(' on page .',2)
              CALL ZPTINT(CURPAG,1,2)
              CALL ZMESS(' too long].',2)
          END IF
      END IF
C
C  RESET THE LINE-AT-A-TIME VALUES AND CHECK FOR BOTTOM
C  OF PAGE.
C
      TIVAL = INVAL
      CALL SKIPF(MIN(LSVAL-1,BOTTOM-LINENO))
      LINENO = LINENO + LSVAL
      IF (LINENO.GT.BOTTOM) CALL PFOOT
 
      END
C------------------------------------------------
      SUBROUTINE PUTBAK(C)
 
      INTEGER C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER BP
      INTEGER BUF(400)
      COMMON /CDEFIO/ BP, BUF
 
      SAVE
 
      BP = BP + 1
      IF (BP.GT.400) CALL ERROR(
     +                   'RF: TOO MANY CHARACTERS PUSHED BACK (PUTBAK).'
     +                              )
      BUF(BP) = C
 
      END
C------------------------------------------------
      SUBROUTINE PUTTL(BUF,LIM,PAGENO)
 
      INTEGER BUF(*),CHARS(20),DELIM,CDATE(15)
      INTEGER PAGENO,LIM(*),LAST(8)
      INTEGER NC,ITOC,I,J,N,LEFT,RIGHT,GFIELD,NCD,NOW(7)
      INTEGER LENGTH
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER TBUF1(134),TBUF2(134),TBUF3(134),TTL(134)
      COMMON /CTEMP/ TBUF1, TBUF2, TTL, TBUF3
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
      SAVE
 
      DATA LAST/32,40,108,97,115,116,41,129/
 
      IF (PRINT.NE.-3) THEN
          LEFT = LIM(1) + 1
          RIGHT = LIM(2) + 1
          NC = ITOC(PAGENO,CHARS,20)
          IF (ATEND) THEN
              CALL SCOPY(LAST,1,CHARS,LENGTH(CHARS)+1)
              NC = LENGTH(CHARS)
          END IF
          CALL GETNOW(NOW)
          CALL FMTDAT(CDATE,NOW,NCD)
          I = 1
          DELIM = BUF(I)
          DO 100 J = 1,RIGHT - 1
              TTL(J) = 32
  100     CONTINUE
 
          N = 0
  200     CONTINUE
          N = N + 1
          IF (GFIELD(BUF,I,RIGHT-LEFT,TBUF1,DELIM).GT.0) THEN
              CALL SUBST(TBUF1,35,TBUF2,CHARS,NC)
              CALL SUBST(TBUF2,37,TBUF1,CDATE,NCD)
              CALL JUSTFY(TBUF1,LEFT,RIGHT,TJUST(N),TTL)
          END IF
          IF (BUF(I).NE.129 .AND. BUF(I).NE.10 .AND.
     +        N.NE.3) GO TO 200
  300     CONTINUE
 
          IF (RIGHT.GT.1 .AND. TTL(RIGHT-1).EQ.32) THEN
              RIGHT = RIGHT - 1
              GO TO 300
          END IF
          TTL(RIGHT) = 10
          TTL(RIGHT+1) = 129
          I = 1
          DO 400 I = 1,OFFSET
              CALL PUTCH(32,FDOUT)
  400     CONTINUE
          CALL PUTLIN(TTL,FDOUT)
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE PUTWRD(WRDBUF)
 
      INTEGER WRDBUF(*)
      INTEGER LENGTH,WIDTH
      INTEGER LAST,LLVAL,NEXTRA,W
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER OUTP, OUTW, OUTWDS
      INTEGER OUTBUF(400)
      LOGICAL ATEND, LEGEN
      COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      W = WIDTH(WRDBUF)
      LAST = LENGTH(WRDBUF) + OUTP
      LLVAL = RMVAL - TIVAL
      IF (OUTW+W.GT.LLVAL+1 .OR. LAST.GE.400) THEN
          LAST = LAST - OUTP
          NEXTRA = LLVAL - OUTW
          OUTP = OUTP + 1
  100     CONTINUE
          IF (OUTP.GT.1) THEN
              IF (OUTBUF(OUTP-1).EQ.32) THEN
                  NEXTRA = NEXTRA + 1
                  OUTP = OUTP - 1
                  GO TO 100
              END IF
          END IF
          IF (RJUST.EQ.-2) THEN
              CALL SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS)
              IF (NEXTRA.GT.0 .AND. OUTWDS.GT.1) OUTP = OUTP + NEXTRA
          END IF
          CALL BRK
      END IF
 
      CALL SCOPY(WRDBUF,1,OUTBUF,OUTP+1)
      OUTP = LAST
      OUTW = OUTW + W
      OUTWDS = OUTWDS + 1
 
      END
C------------------------------------------------
      SUBROUTINE SPACE(N)
 
      INTRINSIC MIN
      INTEGER N
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
      SAVE
 
      CALL BRK
      IF (LINENO.LE.BOTTOM) THEN
          IF (LINENO.EQ.0) CALL PHEAD
          CALL SKIPF(MIN(N,BOTTOM+1-LINENO))
          LINENO = LINENO + N
          IF (LINENO.GT.BOTTOM) CALL PFOOT
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE SPREAD(BUF,OUTP,NEXTRA,OUTWDS)
 
      INTEGER BUF(*)
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
      INTEGER DIR,I,J,NB,NE,NEXTRA,NHOLES,OUTP,OUTWDS
      INTRINSIC MIN
      DATA DIR/0/
 
      IF (NEXTRA.GT.0 .AND. OUTWDS.GT.1) THEN
          DIR = 1 - DIR
          NE = NEXTRA
          NHOLES = OUTWDS - 1
          IF (TIVAL.NE.INVAL .AND. NHOLES.GT.1) NHOLES = NHOLES - 1
          I = OUTP - 1
          J = MIN(400-2,I+NE)
  100     CONTINUE
          IF (I.LT.J) THEN
              BUF(J) = BUF(I)
              IF (BUF(I).EQ.32 .AND. BUF(I-1).NE.32) THEN
                  IF (DIR.EQ.0) THEN
                      NB = (NE-1)/NHOLES + 1
                  ELSE
                      NB = NE/NHOLES
                  END IF
                  NE = NE - NB
                  NHOLES = NHOLES - 1
  200             CONTINUE
                  IF (NB.GT.0) THEN
                      J = J - 1
                      BUF(J) = 32
                      NB = NB - 1
                      GO TO 200
                  END IF
              END IF
              I = I - 1
              J = J - 1
              GO TO 100
          END IF
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE SUBST(IN,CHAR,OUT,SUBARA,N)
 
      INTEGER IN(*),CHAR,OUT(*),SUBARA(*)
      INTEGER I,J,K,N
 
      J = 1
      I = 1
  100 CONTINUE
      IF (IN(I).NE.129) THEN
          IF (IN(I).NE.CHAR) THEN
              OUT(J) = IN(I)
              J = J + 1
              I = I + 1
          ELSE
              K = 1
  200         CONTINUE
              IF (K.LE.N) THEN
                  OUT(J) = SUBARA(K)
                  J = J + 1
                  K = K + 1
                  GO TO 200
              END IF
              I = I + 1
          END IF
          GO TO 100
      END IF
      OUT(J) = 129
 
      END
C------------------------------------------------
      SUBROUTINE TEXT(INBUF)
 
      INTEGER INBUF(*),WRDBUF(400)
      INTEGER GETWRB,LENGTH
      INTEGER I,CUFLG
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
     +        CCHAR, BSVAL, RJUST, CUVAL
      INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
      LOGICAL EMBEDU, EMBEDB
      COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
     +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
     +                EMBEDU,CHUBED,EMBEDB,CHBBED
 
      SAVE
 
      DATA CUFLG/-3/
 
      CALL DOESC(INBUF,WRDBUF,400)
      CALL DOTABS(INBUF,WRDBUF,400)
      IF (INBUF(1).EQ.32 .OR. INBUF(1).EQ.10) CALL LEADBL(INBUF)
      IF (ULVAL.GT.0) THEN
          CALL UNDERL(INBUF,WRDBUF,400)
          ULVAL = ULVAL - 1
      END IF
      IF (CUVAL.GT.0) THEN
          IF (CUFLG.EQ.-3) THEN
              CALL SCOPY(INBUF,1,WRDBUF,1)
              INBUF(1) = -10
              CALL SCOPY(WRDBUF,1,INBUF,2)
              CUFLG = -2
          END IF
          CUVAL = CUVAL - 1
          IF (CUFLG.EQ.-2 .AND. CUVAL.EQ.0) THEN
              I = LENGTH(INBUF)
              INBUF(I) = -11
              INBUF(I+1) = 10
              INBUF(I+2) = 129
              CUFLG = -3
          END IF
      END IF
      IF (BOVAL.GT.0) THEN
          CALL BOLD2(INBUF,WRDBUF)
          BOVAL = BOVAL - 1
      END IF
      IF (CEVAL.GT.0) THEN
          CALL CENTER(INBUF)
          CALL PUT(INBUF)
          CEVAL = CEVAL - 1
      ELSE IF (INBUF(1).EQ.10) THEN
          CALL PUT(INBUF)
      ELSE IF (FILL.EQ.-3) THEN
          CALL PUT(INBUF)
      ELSE
          I = LENGTH(INBUF)
          INBUF(I) = 32
          IF (INBUF(I-1).EQ.46) THEN
              I = I + 1
              INBUF(I) = 32
          END IF
          INBUF(I+1) = 129
          I = 1
  100     CONTINUE
          IF (GETWRB(INBUF,I,WRDBUF).GT.0) THEN
              CALL PUTWRD(WRDBUF)
              GO TO 100
          END IF
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE UNDERL(BUF,TBUF,SIZE)
 
      INTEGER I,J,SIZE,T,TYPE
      INTEGER BUF(*),TBUF(*)
 
      J = 1
      I = 1
  100 CONTINUE
      IF (J.LT.SIZE-1) THEN
          T = TYPE(BUF(I))
  200     CONTINUE
          IF (T.NE.1 .AND. T.NE.2 .AND. T.NE.10 .AND.
     +        T.NE.129) THEN
              TBUF(J) = BUF(I)
              I = I + 1
              J = J + 1
              T = TYPE(BUF(I))
              GO TO 200
          END IF
          IF (BUF(I).NE.129 .AND. BUF(I).NE.10) THEN
              TBUF(J) = -10
              J = J + 1
              T = TYPE(BUF(I))
  300         CONTINUE
              IF (T.EQ.1 .OR. T.EQ.2 .OR. T.EQ.45) THEN
                  TBUF(J) = BUF(I)
                  I = I + 1
                  J = J + 1
                  T = TYPE(BUF(I))
                  GO TO 300
              END IF
              TBUF(J) = -11
              J = J + 1
              GO TO 100
          END IF
      END IF
 
      TBUF(J) = 10
      TBUF(J+1) = 129
      CALL SCOPY(TBUF,1,BUF,1)
 
      END
C------------------------------------------------
      INTEGER FUNCTION WIDTH(BUF)
 
      INTEGER BUF(*)
      INTEGER I
 
      WIDTH = 0
      I = 1
  100 CONTINUE
 
      IF (BUF(I).NE.129) THEN
          IF (BUF(I).EQ.8) THEN
              WIDTH = WIDTH - 1
          ELSE IF ((BUF(I).GE.32.AND.BUF(I).LE.126) .OR.
     +             (BUF(I).EQ.-20)) THEN
              WIDTH = WIDTH + 1
          END IF
          I = I + 1
          GO TO 100
      END IF
 
      END
C------------------------------------------------
      INTEGER FUNCTION ITOA(INT,CHR)
 
      INTEGER INT
      INTEGER CHR,ALPHA(26)
      INTEGER D,INTVAL
      INTRINSIC MOD
 
      DATA ALPHA/122,97,98,99,100,101,102,103,104,105,106,
     +     107,108,109,110,111,112,113,114,115,116,117,118,
     +     119,120,121/
 
      INTVAL = IABS(INT)
      D = MOD(INTVAL,26)
      CHR = ALPHA(D+1)
      ITOA = 1
 
      END
C------------------------------------------------
C
      INTEGER FUNCTION ADDSTR(S,STR,J,MAXSIZ)
 
      INTEGER J,MAXSIZ
      INTEGER S(*),STR(MAXSIZ)
      INTEGER I,ADDSET
 
      I = 1
  100 CONTINUE
      IF (S(I).NE.129) THEN
          IF (ADDSET(S(I),STR,J,MAXSIZ).EQ.-3) THEN
              GO TO 200
          ELSE
              I = I + 1
              GO TO 100
          END IF
      END IF
 
      ADDSTR = -2
      RETURN
  200 ADDSTR = -3
 
      END
C------------------------------------------------
C
C  FORMAT THE DATE FOR HEADERS AND FOOTERS, USE A
C  TEXTUAL DATE TO AVOID THE PROBLEMS OF UK/USA
C  DATE FORMATS
C
      SUBROUTINE FMTDAT(DATE,NOW,LENT)
 
      INTEGER DATE(*),NOW(*)
      INTEGER TRIP,LENT,J
      INTEGER MONS(3,12),TEMP(6)
      INTEGER ITOC
      EXTERNAL ITOC
      SAVE
 
      DATA (MONS(I,1),I=1,3)/74,97,110/
      DATA (MONS(I,2),I=1,3)/70,101,98/
      DATA (MONS(I,3),I=1,3)/77,97,114/
      DATA (MONS(I,4),I=1,3)/65,112,114/
      DATA (MONS(I,5),I=1,3)/77,97,121/
      DATA (MONS(I,6),I=1,3)/74,117,110/
      DATA (MONS(I,7),I=1,3)/74,117,108/
      DATA (MONS(I,8),I=1,3)/65,117,103/
      DATA (MONS(I,9),I=1,3)/83,101,112/
      DATA (MONS(I,10),I=1,3)/79,99,116/
      DATA (MONS(I,11),I=1,3)/78,111,118/
      DATA (MONS(I,12),I=1,3)/68,101,99/
 
      TRIP = ITOC(NOW(3),TEMP,3)
      IF (TRIP.EQ.1) THEN
          DATE(1) = 48
          DATE(2) = TEMP(1)
      ELSE
          DATE(1) = TEMP(1)
          DATE(2) = TEMP(2)
      END IF
 
      DATE(3) = 32
      DATE(7) = 32
      DATE(12) = 129
      DO 100 J = 1,3
          DATE(3+J) = MONS(J,NOW(2))
  100 CONTINUE
      TRIP = ITOC(NOW(1),TEMP,5)
      DATE(8) = TEMP(1)
      DATE(9) = TEMP(2)
      DATE(10) = TEMP(3)
      DATE(11) = TEMP(4)
 
      LENT = 11
 
      END
C------------------------------------------------
      SUBROUTINE GETNOW(NOW)
 
      INTEGER NOW(7),YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,MILLI
 
      CALL ZTIME(YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,MILLI)
 
      NOW(1) = YEAR
      NOW(2) = MONTH
      NOW(3) = DAY
      NOW(4) = HOUR
      NOW(5) = MINUTE
      NOW(6) = SECOND
      NOW(7) = MILLI
 
      END
C------------------------------------------------
C
C  OUTPUT THE SPECIFIED NUMBER OF BLANK LINES ON THE
C  OUTPUT UNIT SPECIFIED BY THE FILE DESCRIPTOR FDOUT.
C
      SUBROUTINE SKIPF(COUNT)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
     +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
     +        NOWARN, FDSAVE
      LOGICAL STOPH, STOPF, STOPP, NORMFD
      INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
     +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
     +        LINEXX(134), LINLIM(2)
      COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
     +               BOTTOM,STOPH,STOPF,STOPP,
     +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
     +               EHEAD,OHEAD,EHLIM,OHLIM,
     +               EFOOT,OFOOT,EFLIM,OFLIM,
     +               LINEXX, LINLIM, NOWARN
      INTEGER COUNT,I
      SAVE
 
      DO 100 I = 1,COUNT
          CALL PUTCH(10,FDOUT)
  100 CONTINUE
 
      END
C=============================================================
C
C  INTERNAL DEFINITION TABLE HANDLING ROUTINES
C  (* - USED BY MAIN PROGRAM)
C
C * DSINIT    INITIALISE THE STORAGE TABLE
C   DSFREE    FREE SPACE IN THE STORAGE TABLE
C   DSGET     ALLOCATE SPACE IN THE STORAGE TABLE
C * ENTDEF    ENTER A DEFINITION INTO THE TABLE
C   ENTER
C   LOOKUP    SEE IF A SYMBOL ALREADY HAS A DEFINITION
C * LUDEF     LOOK FOR, AND RETURN, A DEFINITION
C   MKTABL    INITIALISE THE HASH TABLE
C   STLU
C
C------------------------------------------------
C
C  INITIALISE THE INTERNAL DEFINITIONS TABLE. THIS TABLE
C  CONTAINS A LINKED LIST OF FREE SPACE THAT CAN BE ALLOCATED
C  USING DSGET AND RELEASED USING DSFREE.
C
C  MEM(1) = THE SIZE OF THE MEMORY BUFFER
C  MEM(2) = THE SIZE OF THE FIRST BLOCK OF FREE SPACE(ALWAYS
C           SET TO 0, THIS IS A DUMMY ENTRY IN THE LINKED LIST)
C  MEM(3) = POINTER TO THE NEXT ELEMENT OF THE LINKED LIST
C  MEM(4) = THE AMOUNT OF FREE SPACE IN THE(USUALLY LAST)
C           ELEMENT OF THE LINKED LIST.
C
C  THE LINKED LIST CONTAINS A NUMBER OF ELEMENTS EACH CONSISTING
C  OF THREE PARTS:
C
C     A) THE SIZE OF THE FREE SPACE IN THIS ELEMENT
C     B) A POINTER TO THE NEXT ELEMENT
C     C) THE FREE SPACE
C
      SUBROUTINE DSINIT
 
      INTEGER MKTABL
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      MEM(1) = MEMSIZ
      MEM(2) = 0
      MEM(3) = 4
      MEM(4) = MEMSIZ - 3
      MEM(5) = 0
 
      MACTBL = MKTABL(1)
 
      END
C------------------------------------------------
C
C  ENTER A DEFINITION INTO THE DEFINITION TABLE. NOTE
C  THAT IF THE DEFINITION ALREADY EXISTS THEN THE SPACE
C  ASSOCIATED WITH IT IS FIRST FREED.
C
      SUBROUTINE ENTDEF(NAME,DEFN)
 
      INTEGER NAME(*),DEFN(*),LOCN(2)
      INTEGER I
      INTEGER LENGTH,DSGET
      LOGICAL LOOKUP
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      IF (LOOKUP(NAME,LOCN,MACTBL)) CALL DSFREE(LOCN(1))
      LOCN(1) = DSGET(LENGTH(DEFN)+1)
      CALL ENTER(NAME,LOCN,MACTBL)
 
      I = 1
  100 CONTINUE
      IF (DEFN(I).NE.129) THEN
          MEM(LOCN(1)) = DEFN(I)
          LOCN(1) = LOCN(1) + 1
          I = I + 1
          GO TO 100
      END IF
      MEM(LOCN(1)) = 129
 
      END
C------------------------------------------------
      LOGICAL FUNCTION LUDEF(NAME,DEFN)
 
      INTEGER NAME(*),DEFN(*),LOCN(2)
      INTEGER I
      LOGICAL LOOKUP
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      IF (.NOT.LOOKUP(NAME,LOCN,MACTBL)) THEN
          DEFN(1) = 129
          LUDEF = .FALSE.
      ELSE
 
          I = 1
  100     CONTINUE
          IF (MEM(LOCN(1)).NE.129) THEN
              DEFN(I) = MEM(LOCN(1))
              LOCN(1) = LOCN(1) + 1
              I = I + 1
              GO TO 100
          END IF
          DEFN(I) = 129
          LUDEF = .TRUE.
      END IF
 
      END
C------------------------------------------------
      SUBROUTINE DSFREE(BLOCK)
 
      INTEGER BLOCK,P0,P,Q,N
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      P0 = BLOCK - 2
      N = MEM(P0)
      Q = 2
  100 CONTINUE
 
      P = MEM(Q+1)
      IF (P.NE.0 .AND. P.LE.P0) THEN
          Q = P
          GO TO 100
      END IF
 
      IF (Q+MEM(Q).GT.P0) CALL ERROR(
     +                     '[ISTRF: ATTEMPT TO FREE UNALLOCATED BLOCK].'
     +                               )
 
      IF (P0+N.EQ.P .AND. P.NE.0) THEN
          N = N + MEM(P)
          MEM(P0+1) = MEM(P+1)
      ELSE
          MEM(P0+1) = P
      END IF
 
      IF (Q+MEM(Q).EQ.P0) THEN
          MEM(Q) = MEM(Q) + N
          MEM(Q+1) = MEM(P0+1)
      ELSE
          MEM(Q+1) = P0
          MEM(P0) = N
      END IF
 
      END
C------------------------------------------------
      INTEGER FUNCTION DSGET(WIDTH)
 
      INTEGER WIDTH,POINT,OLDPNT,LINK,NEED,LEFT
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      NEED = WIDTH + 2
      OLDPNT = 2
  100 CONTINUE
 
      POINT = MEM(OLDPNT+1)
      IF (POINT.EQ.0) CALL ERROR('[ISTRF: OUT OF STORAGE].')
 
      IF (MEM(POINT).LT.NEED) THEN
          OLDPNT = POINT
          GO TO 100
      END IF
 
      LEFT = MEM(POINT) - NEED
 
      IF (LEFT.GE.8) THEN
          MEM(POINT) = LEFT
          LINK = POINT + LEFT
          MEM(LINK) = NEED
      ELSE
          MEM(OLDPNT+1) = MEM(POINT+1)
          LINK = POINT
      END IF
 
      DSGET = LINK + 2
 
      END
C------------------------------------------------
      SUBROUTINE ENTER(SYMBOL,INFO,ST)
 
      INTEGER SYMBOL(*),INFO(*)
      INTEGER ST,I,NODSIZ,J,NODE,PRED
      INTEGER LENGTH,DSGET
      LOGICAL STLU
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      NODSIZ = MEM(ST)
      IF (.NOT.STLU(SYMBOL,NODE,PRED,ST)) THEN
          NODE = DSGET(1+NODSIZ+LENGTH(SYMBOL)+1)
          MEM(NODE) = 0
          MEM(PRED) = NODE
          I = 1
          J = NODE + 1 + NODSIZ
  100     CONTINUE
          IF (SYMBOL(I).NE.129) THEN
              MEM(J) = SYMBOL(I)
              I = I + 1
              J = J + 1
              GO TO 100
          END IF
          MEM(J) = 129
      END IF
 
      I = 1
  200 CONTINUE
      IF (I.LE.NODSIZ) THEN
          J = NODE + 1 + I - 1
          MEM(J) = INFO(I)
          I = I + 1
          GO TO 200
      END IF
 
      END
C------------------------------------------------
C
C  SEE IF A DEFINITION ALREADY EXISTS FOR THE SPECIFIED SYMBOL
C
      LOGICAL FUNCTION LOOKUP(SYMBOL,INFO,ST)
 
      INTEGER SYMBOL(*),INFO(*)
      INTEGER ST,I,NODSIZ,KLUGE,NODE,PRED
      LOGICAL STLU
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      IF (.NOT.STLU(SYMBOL,NODE,PRED,ST)) THEN
          LOOKUP = .FALSE.
      ELSE
 
          NODSIZ = MEM(ST)
          I = 1
  100     CONTINUE
 
          IF (I.LE.NODSIZ) THEN
              KLUGE = NODE + 1 - 1 + I
              INFO(I) = MEM(KLUGE)
              I = I + 1
              GO TO 100
          END IF
 
          LOOKUP = .TRUE.
      END IF
 
      END
C------------------------------------------------
C
C  SAVE SPACE FOR THE HASH TABLE
C
      INTEGER FUNCTION MKTABL(NODSIZ)
 
      INTEGER NODSIZ,ST,I
      INTEGER DSGET
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      ST = DSGET(43+1)
      MEM(ST) = NODSIZ
      MKTABL = ST
 
      DO 100 I = ST + 1,ST + 43
          MEM(I) = 0
  100 CONTINUE
 
      END
C------------------------------------------------
C
C  SEE IF THE SPECIFIED SYMBOL ALREADY EXISTS IN THE TABLE.
C  ST = START OF HASH TABLE.
C
      LOGICAL FUNCTION STLU(SYMBOL,NODE,PRED,ST)
 
      INTEGER SYMBOL(*)
      INTEGER NODE,PRED,ST
      INTEGER HASH,I,J,NODSIZ
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
      INTEGER MACTBL, MEMSIZ
      PARAMETER (MEMSIZ = 2500)
      INTEGER MEM(MEMSIZ)
      COMMON/CDSMEM/MEM, MACTBL
 
      SAVE
 
      NODSIZ = MEM(ST)
      HASH = 0
      I = 1
  100 CONTINUE
 
      IF (SYMBOL(I).NE.129) THEN
          HASH = HASH + SYMBOL(I)
          I = I + 1
          GO TO 100
      END IF
 
      HASH = MOD(HASH,43) + 1
      PRED = ST + HASH
      NODE = MEM(PRED)
  200 CONTINUE
 
      IF (NODE.NE.0) THEN
          I = 1
          J = NODE + 1 + NODSIZ
  300     CONTINUE
          IF (SYMBOL(I).EQ.MEM(J)) THEN
              IF (SYMBOL(I).EQ.129) THEN
                  GO TO 400
              ELSE
                  I = I + 1
                  J = J + 1
                  GO TO 300
              END IF
          END IF
 
          PRED = NODE
          NODE = MEM(PRED)
          GO TO 200
      END IF
 
      STLU = .FALSE.
      RETURN
  400 STLU = .TRUE.
 
      END
